unit ecxmlsaxtokenizer;

{$IFDEF FPC}
{$H+}
{$ENDIF}
interface

uses
  Classes, SysUtils, XMLSupport;

const
  toComment = Char(6);
  toToken = Char(7);
  toHeader = Char(8);
  toText = Char(9);
  toOpen = Char(10);
  toClose = Char(11);
  toStandAlone = Char(12);
  toCDATA = Char(13);

type
  TXMLHeader           = procedure(Sender: TObject; Symbol : AnsiString; Params : TXMLParamList)of object;
  TXMLStartElement     = procedure(Sender: TObject; Symbol : AnsiString; Params : TXMLParamList)of object;
  TXMLEndElement       = procedure(Sender: TObject; Symbol : AnsiString)of object;
  TXMLStandAloneElement= procedure(Sender: TObject; Symbol : AnsiString; Params : TXMLParamList)of object;
  TXMLComment          = procedure(Sender: TObject; Contents : AnsiString)of object;
  TXMLCData            = procedure(Sender: TObject; Contents : AnsiString)of object;
  TXMLText             = procedure(Sender: TObject; Contents : AnsiString)of object;
  TXMLException        = procedure(const ABaseMessage, APreview : AnsiString; const AtLine, AtLinePos : Integer; var Handled : Boolean) of object;
  TXMLExceptionType    = (etException, etWarning);
  { TXMLTokenizerException }
  
  TXMLTokenizerException = class(Exception)
  private
    FBaseMessage: AnsiString;
    FLineNo: LongInt;
    FLinePos: LongInt;
    FPreview: AnsiString;
  public
    constructor Create(ExceptionType : TXMLExceptionType; const ABaseMessage, APreview : AnsiString; const AtLine, AtLinePos : Integer);

    property LineNo : LongInt read FLineNo write FLineNo;
    property LinePos: LongInt read FLinePos write FLinePos;
    property BaseMessage : AnsiString read FBaseMessage write FBaseMessage;
    property Preview : AnsiString read FPreview write FPreview;
  end;

  { TXMLTokenizer }

  TXMLTokenizer = class(TObject)
  private
    FLineStartNumber: LongInt;
    FLineStartPos: LongInt;
    FOnException: TXMLException;
    FToken : Char;
    FLineNumber: LongInt;
    FLinePos: LongInt;
    FOnCData: TXMLCData;
    FOnComment: TXMLComment;
    FOnEndElement: TXMLEndElement;
    FOnHeader: TXMLHeader;
    FOnStandAloneElement: TXMLStandAloneElement;
    FOnStartElement: TXMLStartElement;
    FOnText: TXMLText;
    FPosition: LongInt;
    FSource: PChar;
    FRunning : Boolean;
    FTokenLength: LongInt;
    FParams : TXMLParamList;
    FTokenStart: LongInt;
    FCurrToken : Char;
    function GetIsEOF: Boolean;
    function GetTokenText: AnsiString;
    procedure SetOnCData(const AValue: TXMLCData);
    procedure SetOnComment(const AValue: TXMLComment);
    procedure SetOnEndElement(const AValue: TXMLEndElement);
    procedure SetOnException(const AValue: TXMLException);
    procedure SetOnHeader(const AValue: TXMLHeader);
    procedure SetOnStandAloneElement(const AValue: TXMLStandAloneElement);
    procedure SetOnStartElement(const AValue: TXMLStartElement);
    procedure SetOnText(const AValue: TXMLText);
    procedure SetSource(const AValue: PChar);

    procedure DoHeader(Symbol : AnsiString; Params : TXMLParamList);
    procedure DoStartElement(Symbol : AnsiString; Params : TXMLParamList);
    procedure DoEndElement(Symbol : AnsiString);
    procedure DoStandAloneElement(Symbol : AnsiString; Params : TXMLParamList);
    procedure DoComment(Contents : AnsiString);
    procedure DoCData(Contents : AnsiString);
    procedure DoText(Contents : AnsiString);
    
    function ScanElement : Char;
    function ScanHeader : Char;
    function ScanComment : Char;
    function ScanCData : Char;
    function ScanBash : Char;
    procedure ScanParams;
    
    procedure Match(Str:AnsiString);
    
    procedure SkipBlanks;
    procedure NextChar;
    procedure NewLine;
    function  SourceChar : Char;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Reset;
    procedure Start;
    procedure Stop;
    function  NextToken : Char;

    procedure Error(const Ident: AnsiString);
    procedure ErrorFmt(const Message: AnsiString; const Args: array of const);

    procedure Throw(ErrorMessage : String);

    property Source     : PChar read FSource write SetSource;
  published
    property LineNumber : LongInt read FLineStartNumber;
    property LinePos    : LongInt read FLineStartPos;
    property TokenLength: LongInt read FTokenLength;
    property Position   : LongInt read FPosition;
    property TokenStart : LongInt read FTokenStart;

    property TokenText  : AnsiString read GetTokenText;
    property Token      : Char read FToken;
    
    property EOF        : Boolean read GetIsEOF;

    property OnHeader            : TXMLHeader read FOnHeader write SetOnHeader;
    property OnStartElement      : TXMLStartElement read FOnStartElement write SetOnStartElement;
    property OnEndElement        : TXMLEndElement read FOnEndElement write SetOnEndElement;
    property OnStandAloneElement : TXMLStandAloneElement read FOnStandAloneElement write SetOnStandAloneElement;
    property OnComment           : TXMLComment read FOnComment write SetOnComment;
    property OnCData             : TXMLCData read FOnCData write SetOnCData;
    property OnText              : TXMLText read FOnText write SetOnText;
    
    property OnException         : TXMLException read FOnException write SetOnException;
  end;

implementation

const
  SParseErrorTLP = 'Expected %s but %s found at line %d pos %d';
  SParseErrorLP  = 'Expected %s at line %d pos %d';

{ TXMLTokenizer }

procedure TXMLTokenizer.SetOnCData(const AValue: TXMLCData);
begin
//  if FOnCData =AValue then exit;
  FOnCData:=AValue;
end;

function TXMLTokenizer.GetTokenText: AnsiString;
begin
  result := '';
  SetString(Result, (FSource+FTokenStart), FTokenLength);
end;

function TXMLTokenizer.GetIsEOF: Boolean;
begin
  if FSource = nil then
    result := true
  else
    result := (FCurrToken = #0) and ((FSource+FPosition)^ = #0);
end;

procedure TXMLTokenizer.SetOnComment(const AValue: TXMLComment);
begin
//  if FOnComment=AValue then exit;
  FOnComment:=AValue;
end;

procedure TXMLTokenizer.SetOnEndElement(const AValue: TXMLEndElement);
begin
//  if FOnEndElement=AValue then exit;
  FOnEndElement:=AValue;
end;

procedure TXMLTokenizer.SetOnException(const AValue: TXMLException);
begin
//  if FOnException=AValue then exit;
  FOnException:=AValue;
end;

procedure TXMLTokenizer.SetOnHeader(const AValue: TXMLHeader);
begin
//  if FOnHeader=AValue then exit;
  FOnHeader:=AValue;
end;

procedure TXMLTokenizer.SetOnStandAloneElement(
  const AValue: TXMLStandAloneElement);
begin
//  if FOnStandAloneElement=AValue then exit;
  FOnStandAloneElement:=AValue;
end;

procedure TXMLTokenizer.SetOnStartElement(const AValue: TXMLStartElement);
begin
///  if FOnStartElement=AValue then exit;
  FOnStartElement:=AValue;
end;

procedure TXMLTokenizer.SetOnText(const AValue: TXMLText);
begin
//  if FOnText=AValue then exit;
  FOnText:=AValue;
end;

procedure TXMLTokenizer.SetSource(const AValue: PChar);
begin
  Reset;
  if FSource=AValue then exit;
  FSource:=AValue;
end;

procedure TXMLTokenizer.DoHeader(Symbol: AnsiString; Params: TXMLParamList);
begin
  if Assigned(FOnHeader) then
    FOnHeader(Self, Symbol, Params);
end;

procedure TXMLTokenizer.DoStartElement(Symbol: AnsiString; Params: TXMLParamList);
begin
  if Assigned(FOnStartElement) then
    FOnStartElement(Self, Symbol, Params);
end;

procedure TXMLTokenizer.DoEndElement(Symbol: AnsiString);
begin
  if Assigned(FOnEndElement) then
    FOnEndElement(Self, Symbol);
end;

procedure TXMLTokenizer.DoStandAloneElement(Symbol: AnsiString; Params: TXMLParamList);
begin
  if Assigned(FOnStandAloneElement) then
    FOnStandAloneElement(Self, Symbol, Params);
end;

procedure TXMLTokenizer.DoComment(Contents: AnsiString);
begin
  if Assigned(FOnComment) then
    FOnComment(Self, Contents);
end;

procedure TXMLTokenizer.DoCData(Contents: AnsiString);
begin
  if Assigned(FOnCData) then
    FOnCData(Self, Contents);
end;

procedure TXMLTokenizer.DoText(Contents: AnsiString);
begin
  if Assigned(FOnText) then
    FOnText(Self, Contents);
end;

function TXMLTokenizer.ScanElement : Char;
var
  InName,
  IsEnd : Boolean;
  ElemName : AnsiString;
begin
  InName := true;
  ElemName := '';
  IsEnd := (FSource+Position)^ = '/';
  if IsEnd then NextChar;
  FParams.Clear;
  while (not ((FSource+Position)^ in ['>', #0])) do
    begin
      if InName and ((FSource+Position)^ in [#32, #13, #10, '/']) then
        InName := false;
      if InName and (not ((FSource+Position)^ in ['>', #0..#32])) then
        ElemName := ElemName + (FSource+Position)^;
      if (not InName) and ((FSource+Position)^ in [#0..#32]) then
        ScanParams
      else
        NextChar;
    end;
  if (FSource+Position)^ = '>' then
    NextChar;
  FTokenLength := FPosition-FTokenStart;
{  if (FSource+FPosition)^=#0 then
    Throw('Unexpected end of file found')
  else
    begin}
      if ((FSource+Position-1)^ = '>') and ((FSource+Position-2)^ = '/') then
        begin
          DoStandAloneElement(ElemName, FParams);
          result := toStandAlone;
        end
      else
        begin
          if IsEnd then
            begin
              DoEndElement(ElemName);
              result := toClose;
            end
          else
            begin
              DoStartElement(ElemName, FParams);
              result := toOpen;
            end;
        end;
    //end;
end;

function TXMLTokenizer.ScanHeader : Char;
var
  hdrstart  : LongInt;
  hdr   : AnsiString;
  InName : Boolean;
begin
  Match('?');
  hdrstart := FPosition;
  InName := true;
  FParams.Clear;
  while ((FSource+FPosition)^<>'>') and
        (((FSource+FPosition+1)^<>'?') and
        ((FSource+FPosition+2)^<>'>')) and
        ((FSource+FPosition)^<>#0) do
    begin
      if InName and ((FSource+FPosition)^ in ['/', #1..#32, '>', '?']) then
        begin
          hdr := '';
          SetString(hdr, FSource+hdrstart, FPosition-hdrstart);
          InName := false;
          ScanParams;
        end
      else
        NextChar;
    end;
  if (FSource+FPosition)^=#0 then
    Throw('Unexpected end of file found')
  else
    begin
      while not ((FSource+FPosition)^='>') do
        inc(FPosition);
      inc(FPosition);
      FTokenLength := FPosition-FTokenStart;
      DoHeader(hdr, FParams);
      result := toHeader;
    end;
end;

function TXMLTokenizer.ScanComment : Char;
var
  cmntstart  : LongInt;
  cmnt   : AnsiString;
begin
  Match('--');
  cmntstart := FPosition;
  while (((FSource+FPosition+1)^<>'-') and
         ((FSource+FPosition+2)^<>'-') and
         ((FSource+FPosition+3)^<>'>')) and
        ((FSource+FPosition)^<>#0) do
    NextChar;
  if (FSource+FPosition)^=#0 then
    Throw('Unexpected end of file found')
  else
    begin
      cmnt := '';
      SetString(cmnt, FSource+cmntstart, FPosition-cmntstart+1);
      inc(FPosition, 5);
      FTokenLength := FPosition-FTokenStart;
      DoComment(cmnt);
      result := toComment;
    end;
end;

function TXMLTokenizer.ScanCData : Char;
var
  cdstart  : LongInt;
  cd   : AnsiString;
begin
  Match('[CData[');
  cdstart := FPosition;
  while (((FSource+FPosition+1)^<>']') and
         ((FSource+FPosition+2)^<>']') and
         ((FSource+FPosition+3)^<>'>')) and
        ((FSource+FPosition)^<>#0) do
    NextChar;
  if (FSource+FPosition)^=#0 then
    Throw('Unexpected end of file found')
  else
    begin
      cd := '';
      SetString(cd, FSource+cdstart, FPosition-cdstart+1);
      inc(FPosition, 5);
      FTokenLength := FPosition-FTokenStart;
      DoCData(cd);
      result := toCDATA;
    end;
end;

function TXMLTokenizer.ScanBash : Char;
begin
  NextChar;
  result := #0;
  case (FSource+FPosition)^ of
    '[' : result := ScanCData;
    '-' : result := ScanComment;
  else
    Throw('Malformed XML, expected CData or Comment block');
  end;
end;

procedure TXMLTokenizer.ScanParams;
var
  pStart : LongInt;
  s : AnsiString;
  i{, p: }: LongInt;
  Done : Boolean;
  QuoteState: Boolean;
begin
  FParams.Clear;
  SkipBlanks;
  pStart := FPosition;
  QuoteState := false;
  Done := false;
  while (not Done) do //((FSource+FPosition)^ in [#0, '>', '/'])) do
    begin
      if (FSource+FPosition)^ = '"' then
        QuoteState := not QuoteState;
      if (not QuoteState) and ((FSource+FPosition)^ in ['/', '>', '?']) then
        done := true;
      if not Done then
        NextChar;
    end;
  if (FSource+FPosition)^='"' then
    NextChar;
  s := '';
  SetString(s, FSource+pStart, FPosition-pStart);
  if (FSource+FPosition)^=#0 then
    Throw('Unexpected end of file found');

  QuoteState := false;
  i := 1;

  while i < Length(s) do
    begin
      if s[i] = '"' then
        QuoteState := not QuoteState;
      if (s[i] = #32) and
        (QuoteState = false) then
        begin
          Delete(s, i, 1);
          Insert(#13#10, s, i);
        end;
      inc(i);
    end;
  FParams.Text := s;
  for i := 0 to FParams.Count - 1 do
    begin
      s := Trim(FParams.Values[FParams.Names[i]]);
      if length(s) > 2 then
        begin
          if s[1] = '"' then
            Delete(s, 1, 1);
          if s[Length(s)] = '"' then
            Delete(s, Length(s), 1);
        end;
      s := trim(s);
      FParams.Values[FParams.Names[i]] := s;//XMLToStr(s);
    end;
end;

procedure TXMLTokenizer.Match(Str: AnsiString);
var
  i : Integer;
begin
  i := 1;
  while i <= Length(Str) do
    begin
      if lowerCase((FSource+FPosition)^)=lowerCase(Str[i]) then
        NextChar
      else
        Throw('Malformed XML, trying to match '+Str);
      inc(i);
    end;
end;

procedure TXMLTokenizer.SkipBlanks;
begin
  while True do
    begin
      case SourceChar of
        #0: Exit;
        //#10: NewLine;
        #33..#255:
          Exit;
      end;
      NextChar;
    end;
end;

procedure TXMLTokenizer.NextChar;
begin
  if (FSource+FPosition)^ <> #13 then
    Inc(FLinePos);
  if (FSource+FPosition)^ = #10 then
    NewLine;
  Inc(FPosition);
end;

procedure TXMLTokenizer.NewLine;
begin
  Inc(FLineNumber);
  FLinePos := 1;
end;

function TXMLTokenizer.SourceChar: Char;
begin
  result := FSource[FPosition];
end;

procedure TXMLTokenizer.Reset;
begin
  FLineNumber := 0;
  FLinePos    := 0;
  FPosition   := 0;
  FToken      := toEof;
end;

procedure TXMLTokenizer.Start;
begin
  Reset;
  NextToken;
  FRunning := true;
  while (FToken<>toEOF) and (FRunning) do
    NextToken;
  FRunning := false;
end;

procedure TXMLTokenizer.Stop;
begin
  FRunning := false;
end;

function TXMLTokenizer.NextToken : Char;
var
  ElemName : AnsiString;
begin
  result := toEof;
  if FLineNumber = 0 then
    begin
      FLineNumber := 1;
      FLinePos := 1;
    end;
  SkipBlanks;
  FLineStartNumber := FLineNumber;
  FLineStartPos := FLinePos;
  FTokenStart := FPosition;
  FTokenLength := 0;
  case (FSource+FPosition)^ of
    toEof : ;
    '<'   : begin
              NextChar;
              case (FSource+Position)^ of
                '!' : result := ScanBash;
                '?' : result := ScanHeader;
              else
                result := ScanElement;
              end;
            end;
  else
    result := toText;
    ElemName := '';
    while (not ((FSource+FPosition)^ in ['<', #0])) do
      begin
//        if ((FSource+FPosition)^ in [#1..#32]) then
//          begin
//            SkipBlanks;
//            ElemName := ElemName + #32;
//          end
//        else
//          begin

            ElemName := ElemName + (FSource+Position)^;
            NextChar;
//          end;
      end;
    FTokenLength := FPosition-FTokenStart;
    DoText(ElemName);
  end;
  FCurrToken := result;
end;

procedure TXMLTokenizer.Error(const Ident: AnsiString);
begin
  if TokenText <> '' then
    ErrorFmt(SParseErrorTLP, [Ident, TokenText, FLineNumber, FLinePos])
  else
    ErrorFmt(SParseErrorLP, [Ident, FLineNumber, FLinePos]);
end;

procedure TXMLTokenizer.ErrorFmt(const Message: AnsiString;
  const Args: array of const);
begin
  raise EParserError.CreateFmt(Message, Args);
end;

procedure TXMLTokenizer.Throw(ErrorMessage: AnsiString);
var
  Handled : Boolean;
  preview : AnsiString;
begin
  preview := '';
  if FPosition-FTokenStart > 100 then
    SetString(preview, FSource+FTokenStart, 100)
  else
    SetString(preview, FSource+FTokenStart, FPosition-FTokenStart);

  Handled := false;

  if Assigned(FOnException) then
    FOnException(ErrorMessage, Preview, FLineStartNumber, FLineStartPos, Handled);
  if not Handled then
    raise TXMLTokenizerException.Create(etException, ErrorMessage, Preview, FLineStartNumber, FLineStartPos);
end;

constructor TXMLTokenizer.Create;
begin
  Reset;
  FParams := TXMLParamList.Create;
end;

destructor TXMLTokenizer.Destroy;
begin
  FParams.Free;
  inherited Destroy;
end;

{ TXMLTokenizerException }

constructor TXMLTokenizerException.Create(ExceptionType : TXMLExceptionType; const ABaseMessage, APreview: string;
  const AtLine, AtLinePos: Integer);
begin
  FBaseMessage := ABaseMessage;
  FLineNo := AtLine;
  FLinePos := AtLinePos;
  FPreview := APreview;
  case ExceptionType of
    etException : Message := format('Exception: "%s".'#13#10 + 'On line %d at pos %d.'#13#10'%s', [FBaseMessage, FLineNo, FLinePos, FPreview]);
    etWarning   : Message := format('Warning: "%s".'#13#10 + 'On line %d at pos %d.'#13#10'%s', [FBaseMessage, FLineNo, FLinePos, FPreview]);
   end;
end;

end.
